home *** CD-ROM | disk | FTP | other *** search
/ BMUG PD-ROM BV3 / BMUG PD-ROM Version BV3 (CDRM1097900).iso / Programming / Programming Languages / Pocket Forth 6 / Source / Dictionary.txt next >
Encoding:
Text File  |  1992-05-18  |  42.1 KB  |  1,816 lines  |  [TEXT/McSk]
  1. ; this file is: Dictionary.txt  --  forth words
  2. ; Tue Apr 05, 1988 21:59:10 load files >32K
  3. ; Thu Apr 07, 1988 15:59:46 nested loads
  4. ; Tue Apr 19, 1988 05:05:37 change "?button"
  5. ; Mon Apr 25, 1988 15:10:19 implement macros
  6. ; Tue Apr 26, 1988 19:49:49 optomizing "back"
  7. ; Thu Apr 28, 1988 23:09:23 fix id.  better constant,2constant  add zero
  8. ; Fri Apr 29, 1988 09:43:49 add dliteral
  9. ; Sun May 01, 1988 04:24:52 make variable a macro
  10. ; Thu May 12, 1988 11:41:08 remove (pdo)  add 1- 2- & sp@  use slashFail
  11. ; Sun May 29, 1988 20:16:39 make create shorter
  12. ; Tue May 31, 1988 14:27:25 make +md a 4 byte macro  remove 2-
  13. ; Tue Jun 07, 1988 11:39:00 add r0@, s0@, rp@  redo stod
  14. ; Sun Jun 23, 1991 09:33:00 add open
  15. ; Thu Jan 13, 1992 19:05:00 Floating point math (rewrite 13Apr)
  16. ; Sun Feb 02, 1992 00:02:00 fix back
  17. ; Wed Apr 01, 1992 00:12:00 change stkchk
  18. ; Tue Apr 14, 1992 22:48:00 rearrange to bring essentials toward front
  19. ; Sun Apr 19, 1992 23:24:00 split open into 2 parts, add: ae: ;ae> ?gestalt
  20.  
  21.     DC.B    6,'?ST'            ; "?stack" ( ? -- )
  22.     DC.W    key-theLink
  23. StkChk: CMPA.L    Szero-base(BP),PS
  24.     BGT.S    @0
  25.     RTS
  26.     @0:    JSR    space-base(BP)
  27.       MOVEQ    #42,D0            ; print *  if stack underflow
  28.     JSR    EmitCode-base(BP)
  29.     BRA.S    huh
  30.  
  31.     DC.B    6,'WHA'            ; "whazat" ( -- )
  32.     DC.W    stkchk-theLink
  33. WhaZat:    JSR    here-base(BP)        ; push token address
  34.     JSR    count-base(BP)
  35.     JSR    type-base(BP)        ; type unknown token
  36.     JSR    space-base(BP)
  37.     BRA.S    huh
  38.     
  39.     DC.B    5,'ABO'            ; "abort" ( -- )
  40.     DC.W    whazat-theLink
  41. huh:    MOVEQ    #63,D0            ; send ?  means not found in dict
  42.     JSR    EmitCode-base(BP)
  43.     bsr.s    crlf
  44.     BRA.S    fin
  45.     
  46.     DC.B    4,'QUI'            ; "quit" ( -- )
  47.     DC.W    huh-theLink        ;    clear stacks and restart
  48. fin:    JSR    emptyfs-base(BP)    ; clear pending loads
  49.     MOVE.L    Szero-base(BP),PS    ; reset stack pointer
  50.     CLR.L    fcolon-base(BP)        ; initialize flags
  51.     BSET.B    #7,fint-base(BP)
  52.     JMP    cret-base(BP)
  53.  
  54.     DC.B    2,'CR',0        ; "cr" ( -- ) output CR to screen
  55.     DC.W    fin-theLink
  56. CRLF:    JMP    doCR-Base(BP)
  57.  
  58.     DC.B    3,'.OK'            ; ".ok" ( -- )
  59.     DC.W    crlf-theLink
  60. Prompt:    JSR    space-base(BP)        ; send space
  61.     MOVEQ    #111,D0
  62.     JSR    EmitCode-base(BP)    ; send "o"
  63.     MOVEQ    #107,D0
  64.     JSR    EmitCode-base(BP)    ; send "k"
  65.     JMP    space-base(BP)        ; send another space & return
  66.  
  67.     DC.B    5,'UPP'            ; "upper" ( addr -- )
  68.     DC.W    prompt-theLink        ;   change a string to upper case
  69. Upper:    MOVE    (PS)+,D0
  70.     LEA    0(BP,D0.W),A0        ; get the address
  71.     CLR    D0
  72.     MOVE.B    (A0),D0            ; get count
  73.     @0:    CMPI.B    #$60,0(A0,D0.W)        ; BEGIN  get char at addr + count
  74.     BLE.S    @1            ;   char > 'a'
  75.     CMPI.B    #$7B,0(A0,D0.W)        ;   char < 'z'
  76.     BGE.S    @1            ;   AND IF
  77.     SUBI.B    #32,0(A0,D0.W)        ;     char 32 - -> char THEN
  78.     @1:    DBRA    D0,@0            ; count 1- -> count count NOT UNTIL
  79.     RTS
  80.  
  81.     DC.B    5,'TOK'            ; "token" ( -- ) put a token
  82.     DC.W    upper-theLink        ;   from (IS) into (DP),
  83. Token:    MOVE    #32,-(PS)        ;   which is at end of dict.
  84.     BSR.S    word
  85.     JSR    here-base(BP)        ; Fri Apr 29, 1988 00:27:23 simpl
  86.     BRA.S    Upper
  87.  
  88.     DC.B    6,'HEA'            ; "header" ( -- ) create a header
  89.     DC.W    token-theLink        ;   for the current word at DP
  90. Header:    MOVE    Dict,4(DP)        ; link header to dictionary
  91.     MOVE.L    DP,Dict            ; update DICT
  92.     SUB.L    BP,Dict            ; make it a rel.addr
  93.     LEA    6(DP),DP        ; update DP
  94.     RTS
  95.  
  96.     DC.B    4,'WOR'            ; "word" ( c -- ) c is delimiter
  97.     DC.W    header-theLink        ;   get chars from (IS) into HERE
  98. Word:    MOVE.L    D4,-(SP)        ; preserve the register
  99.     MOVE    (PS)+,D4        ; get delimiter character
  100.     CLR.L    (DP)            ; clear token buffer
  101.     CLR.L    D1            ; clear count
  102.     @0:    MOVE.B    (IS)+,D0        ; get characters until delimiter
  103.     CMP.B    D4,D0
  104.     BEQ.S    @1
  105.     MOVE.B    D0,1(DP,D1)        ; place in token buffer
  106.     ADDQ.B    #1,D1            ; increment count
  107.     BRA.S    @0
  108.     @1:    MOVE.B    D1,(DP)            ; put count in 1st byte of buffer
  109.     BEQ.S    @0            ; if count is 0 repeat
  110.     MOVE.L    (SP)+,D4        ; restore the register
  111.     RTS
  112.  
  113.     DC.B    1,'''',0,0        ; "'" ( -- rel.addr ) return the
  114.     DC.W    word-theLink        ;  cfa of the following word
  115. Tick:    bsr.s    token            ; get the next word
  116.     MOVE    Dict,-(PS)        ; push dict ptr to parmstk
  117.     bsr.s    search            ; lookup the current token
  118.     TST    (PS)+
  119.     BEQ    Whazat
  120.     RTS
  121.  
  122.     DC.B    6,'SEA'            ; "search" ( addr -- cfa t  OR  f )
  123.     DC.W    tick-theLink
  124. Search:    MOVE.L    (DP),D1            ; put token "stem" in D1
  125.     MOVE    (PS),D0            ; use A0 as search pointer
  126.     CLR    fmacro-base(BP)        ; clear the macro flag
  127.     @0:    LEA    0(BP,D0.W),A0        ; DO
  128.     TST    (A0)            ;   IF DictStart  exit NOFIND
  129.     BEQ.S    nofind
  130.     CMP.L    (A0),D1            ;   compare word to candidate
  131.     BEQ.S    find            ;   IF found, exit FIND
  132.     BCHG    #31,D1            ;   set precedence bit
  133.     CMP.L    (A0),D1            ;   compare to "immediate" version
  134.     BEQ.S    ifind            ;   IF found, exit FINDIMM
  135.     BCHG    #31,D1            ;   reset precedence bit
  136.     BCHG    #30,D1            ;   set precedence bit
  137.     CMP.L    (A0),D1            ;   compare to "immediate" version
  138.     BEQ.S    mfind            ;   IF found, exit FINDIMM
  139.     BCHG    #30,D1            ;   reset precedence bit
  140.     MOVE    4(A0),D0        ;   get link rel.address
  141.     BRA.S    @0            ; LOOP
  142. nofind:    CLR    (PS)            ; push fail flag
  143.     RTS
  144.  mfind:    BSET.B    #7,fmacro-base(BP)    ; set macro flag
  145.     BRA.S    find
  146.  ifind:    BSET.B    #7,fimmed-base(BP)    ; set immediate flag
  147.   find:    LEA    6(A0),A0        ; cfa is at 6+nfa
  148.     SUBA.L    BP,A0            ; convert code address to relative
  149.     MOVE    A0,(PS)            ; push code rel address
  150.     MOVE    #-1,-(PS)        ; push success flag
  151.     RTS
  152.  
  153.     DC.B    6,'NUM'            ; "number" ( addr -- n t  OR  f )
  154.     DC.W    search-theLink
  155. Number:    MOVE.L    D4,-(SP)        ; save the register
  156.     CLR.L    D1
  157.     CLR.L    D4            ; clear conversion register
  158.     MOVE    (PS)+,D0        ; get token addr in A0
  159.     LEA    0(BP,D0.W),A0        ; put abs.addr in A0
  160.     CMPI.B    #'-',1(A0)        ; is it negative?
  161.     BNE.S    @0            ; IF yes
  162.     BSET.B    #7,fneg-base(BP)    ;     set negative flag
  163.     MOVE.B    #'0',1(A0)        ;     change dash to zero
  164.     @0:    CLR.L    D0            ; THEN
  165.     MOVE.B    (A0)+,D1        ; get digit count
  166.  digit:    MOVE.B    (A0)+,D0        ; BEGIN get next digit
  167.     SUBI.B    #48,D0            ;     strip ASCII prefix
  168.     BLT.S    @2            ;     if digit too small, FAIL
  169.     CMP    #10,D0            ;     if digit > 9
  170.     BLT.S    @1            ;     adjust for radix>10 values
  171.     SUBI.B    #7,D0            ;     and test again
  172.     CMP    #10,D0
  173.     BLT.S    @2
  174.     @1:    CMP    NBase-base(BP),D0    ;     if base < digit
  175.     BGE.S    @2            ;     FAIL
  176.     MULU    NBase-base(BP),D4    ;     multiply value by base
  177.     ADD    D0,D4            ;     add current digit
  178.     SUBQ.B    #1,D1            ;     decrement count
  179.     BNE.S    digit            ; UNTIL no digits remain
  180.         BCLR    #7,fneg-base(BP)    ; test and clear negative flag
  181.     BEQ.S    @0            ; if set
  182.     NEG    D4            ; Negate it
  183.     @0:    MOVE    D4,-(PS)        ; push number
  184.     MOVE    #-1,-(PS)        ; push success flag
  185.     BRA.S    @3
  186.     @2:    CLR    -(PS)            ; push fail flag
  187.     @3:    MOVE.L    (SP)+,D4        ; restore the register
  188.     RTS
  189.  
  190.     DC.B    7,'FNU'            ; FNUMBER ( dabs.addr -- f )
  191.     DC.W    number-theLink        ; convert string at dabs.addr to fp
  192. fnum:    MOVE.L    (PS)+,-(RS)
  193.     MOVE    #1,-(PS)
  194.     PEA    (PS)
  195.     PEA    $14(DP)
  196.     CLR    -(PS)
  197.     PEA    (PS)
  198.     FPSTR2DEC
  199.     ADDQ.L    #4,PS
  200.     CMPI    #$054E,24(DP)        ; check for NAN##
  201.     BNE.S    @0
  202.     JMP    whazat-base(BP)
  203.     @0:    PEA    $14(DP)
  204.     SUBQ.L    #6,PS
  205.     SUBQ.L    #4,PS
  206.     PEA    (PS)
  207.     FDEC2X
  208.     RTS
  209.     
  210.     DC.B    7,'EXE'            ; "execute" ( cfa -- ) do a routine
  211.     DC.W    fnum-theLink        ;    whose cfa is on the stack
  212. EXECUTE    MOVE    (PS)+,D0        ; pop code address
  213.     JMP    0(BP,D0.W)        ; execute & return
  214.  
  215.     DC.B    8,'MCO'            ; "mcompile" ( cfa -- ) 
  216.     DC.W    Execute-theLink        ; compile subroutine bodies inline 
  217. MComp:    MOVE    (PS)+,D0
  218.     LEA    0(BP,D0.W),A0        ; addr of word
  219.     @0:    MOVE    (A0)+,D0
  220.     CMPI    #$4E75,D0        ; if its an RTS your done
  221.     BEQ.S    @1
  222.     MOVE    D0,(A2)+        ; if not, compile it
  223.     BRA.S    @0            ; do next word
  224.     @1:    RTS
  225.     
  226.     DC.B    128+9,'[CO'        ; "[compile]" ( -- )  compile
  227.     DC.W    mcomp-theLink        ;   the next immediate word
  228. bCompile:
  229.     JSR    tick-base(BP)        ; get the cfa of the next word
  230.     bra.s    compile            ;  and compile a JSR to it
  231.     
  232.     DC.B    7,'COM'            ; "compile" ( cfa -- ) compile a 
  233.     DC.W    bcompile-theLink        ;    call to the cfa on the stack
  234. COMPILE    MOVE    #$04EAB,(DP)+        ; compile "JSR d(A3)"
  235.     BRA.S    Comma            ; compile displacement value
  236.  
  237.     DC.B    9,'IMM'            ; "immediate" ( -- ) make the last
  238.     DC.W    compile-theLink        ;   word defined immediate
  239. IMMED    LEA    0(BP,Dict.W),A0        ; get address of most recent word
  240.     BSET    #7,0(BP,Dict.W)        ; set precedence bit of most recent word
  241.     RTS
  242.  
  243.     DC.B    5,'MAC'            ; "macro" ( -- ) make the last
  244.     DC.W    immed-theLink        ;   word defined an inline macro
  245. marco:    BSET    #6,0(BP,Dict.W)        ; set macro bit of most recent word
  246.     RTS
  247.  
  248.     DC.B    1,':',0,0        ; ":" ( -- ) make a header for a 
  249.     DC.W    marco-theLink        ;   word definition
  250. COLON    JSR    token-Base(BP)        ; make header
  251.     JSR    header-base(BP)
  252.     BRA.S    rbrack            ; enter compile mode
  253.     
  254.     DC.B    129,']',0,0        ; "]" ( -- ) enter compile mode
  255.     DC.W    colon-theLink
  256. rBrack:    BSET    #7,fcolon-base(BP)    ; set colon flag
  257.     RTS
  258.  
  259.     DC.B    129,';',0,0        ; ";" ( -- ) end a word definition
  260.     DC.W    rBrack-theLink
  261. SEMI    MOVE    #$4E75,(DP)+        ; compile "RTS"
  262.     BRA.S    lbrack
  263.     
  264.     DC.B    129,'[',0,0        ; "[" ( -- ) leave compile mode
  265.     DC.W    semi-theLink
  266. lBrack:    CLR.B    fcolon-base(BP)        ; clear colon flag
  267.     RTS
  268.     
  269.     DC.B    7,'LIT'            ; "literal" compiling: ( n -- )
  270.     DC.W    lBrack-theLink        ;   executing: ( -- n )
  271. LITERAL    MOVE    #$03D3C,(DP)+        ; compile move #xxxx,-(PS)
  272.     BRA.S    Comma            ; compile constant
  273.  
  274.     DC.B    64+1,',',0,0        ; "," ( n -- )
  275.     DC.W    literal-theLink
  276. COMMA    MOVE    (PS)+,(DP)+        ; pop number to dictionary
  277.     RTS
  278.  
  279.     DC.B    128+2,',$',0        ; ",$" ( -- )
  280.     DC.W    comma-theLink        ; compile a hex number from input
  281. CommaH:    MOVE    NBase-base(BP),-(RS)
  282.     MOVE    #$10,nbase-base(BP)
  283.     JSR    token-base(BP)
  284.     BSR.S    here
  285.     JSR    number-base(BP)
  286.     MOVE    (RS)+,nbase-base(BP)
  287.     TST    (PS)+
  288.     BEQ    whazat
  289.     BRA.S    comma
  290.  
  291.     DC.B    4,'HER'            ; "here" ( -- addr )
  292.     DC.W    commah-theLink        ;   rel.addr of compile point
  293. here:     MOVE.L    DP,-(PS)
  294.     BRA.S    torel
  295.  
  296.     DC.B    8,'DLI'            ; "dliteral" compiling: ( d -- )
  297.     DC.W    here-theLink        ;   executing: ( -- d )
  298. DLit:    MOVE    #$2D3C,(DP)+        ; compile move.l #xxxx,-(PS)
  299.     MOVE.L    (PS)+,(DP)+        ; compile double number
  300.     RTS
  301.  
  302.     DC.B    4,'>RE'            ; ">rel" (to-rel) ( rel.uu) (rel.ah)
  303.     DC.W    dlit-theLink        ; ( daddr32 -- addr16 )
  304. toRel:    MOVE.L    (PS)+,D0        ; get the Daddr32 from stack
  305.     SUB.L    BP,D0            ; get difference from base addr
  306.     MOVE    D0,-(PS)        ; push the 16 bit part of it
  307.     RTS
  308.  
  309.     DC.B    5,'COU'            ; "count" ( addr -- addr+1 length )
  310.     DC.W    torel-theLink
  311. Count:    CLR    D1
  312.     MOVE    (PS),D0
  313.     MOVE.B    0(BP,D0.W),D1
  314.     ADDQ    #1,(PS)
  315.     MOVE    D1,-(PS)
  316.     RTS
  317.  
  318.     DC.B    64+3,'+MD'        ; "+MD" ( offset -- addr )
  319.     DC.W    count-theLink
  320. MacDat:    ADDI    #theWindow-base,(PS)    ; add data addr to stacked offset
  321.     RTS
  322.     
  323.     DC.B    4,'PAG'            ; "page" ( -- )
  324.     DC.W    macdat-theLink        ; clear the window
  325. Page:    PEA    WContRect-base(BP)    ; The visable part of the window.
  326.     _EraseRect
  327.     MOVE.l    #$90001,-(SP)
  328.     _MoveTo                ; set pen position to home (1,9)
  329.     _PenNormal            ; 1X1, black, patcopy
  330.     MOVE    #4,-(SP)        ; Monaco
  331.     _TextFont
  332.     clr    -(SP)            ; plain text
  333.     _TextFace
  334.     MOVE    #9,-(SP)        ; 9 point
  335.     _TextSize
  336.     clr    -(SP)            ; srcCopy
  337.     _TextMode
  338.     RTS
  339.  
  340.     DC.B    4,'BEE'            ; "beep" ( -- )
  341.     DC.W    page-theLink
  342. Beep:    MOVE.W    #3,-(SP)
  343.     _SysBeep
  344.     RTS
  345.  
  346.     DC.B    64+3,'MON'        ; "mon" ( -- ) execute _Debugger
  347.     DC.W    beep-theLink
  348. Mon:    _DeBugger
  349.     RTS
  350.  
  351.     DC.B    3,'BYE'            ; "bye" ( -- ) set quit flag
  352.     DC.W    mon-theLink
  353. Bye:    ADDQ    #1,doneFlag-base(BP)
  354.     RTS
  355.  
  356. TexD:    DC.W    'TEXT'
  357.  
  358.     DC.B    4,'OPE'            ; "open" ( -- )
  359.     DC.W    bye-theLink
  360. Open:    MOVE.L    #$4B0037,-(SP)        ; point: 75,55
  361.     CLR.L    -(SP)            ; no prompt
  362.     CLR.L    -(SP)            ; no filter
  363.     MOVE    #1,-(SP)        ; 1 type
  364.     PEA    texd-base(BP)
  365.     CLR.L    -(SP)            ; no hook
  366.     PEA    (A2)            ; put sfreply at here
  367.     MOVE    #2,-(SP)
  368.     _Pack3
  369.     TST    (A2)            ; check 'good' field
  370.     BEQ.S    beep            ; beep if cancel
  371.  
  372.     MOVE    6(A2),-(PS)        ; hold the vrefnum on stack        ***
  373.     CLR    D0
  374.     @0:    MOVE.L    10(A2,D0.W),40(A2,D0.W)    ; move the file name to 'pad'      ***
  375.     ADDQ    #4,D0
  376.     CMP    #32,D0
  377.     BLE.S    @0
  378.     ADDQ    #1,openFlag-base(BP)
  379.     RTS
  380.  
  381.     DC.B    3,'-->'            ; "-->" ( -- )
  382.     DC.W    open-theLink
  383. Load:    JSR    token-base(BP)        ; put filename string at here
  384.     CLR    -(PS)            ; set vrefnum to 0 (path is specified)
  385.     BRA.S    load1
  386.     
  387. doLoad:    CLR    D0
  388.     @0:    MOVE.L    40(A2,D0.W),0(A2,D0.W)
  389.     ADDQ    #4,D0
  390.     CMP    #32,D0
  391.     BLE.S    @0
  392.  load1:    MOVE    fsptr-base(BP),D0    ; get file stack pointer
  393.     BMI.S    @1            ;  ... save the offset into text ...
  394.     LEA    fofsets-base(BP),A0    ;  ... at fofsets+fspointer
  395.     MOVE.L    TextO-base(BP),0(A0,D0.W)
  396.     LEA    fends-base(BP),A0    ;  TextE at fends+fspointer
  397.     MOVE.L    TextE-base(BP),0(A0,D0.W)
  398.     @1:    ADDQ    #4,fsptr-base(BP)    ; increment the file stack pointer
  399.     
  400.     MOVE.L    #80,D0            ; create an 80 byte block for
  401.     _NewPtr.CLEAR            ; make the file control buffer
  402.     MOVE.L    A0,A4            ; save it for later
  403.     MOVE.B    #1,27(A0)        ; set read only permission
  404.     MOVE.L    DP,18(A0)        ; set name pointer
  405.     MOVE    (PS)+,22(A0)        ; set vrefnum (working directory)
  406.     _HOpen
  407.     TST    16(A0)
  408.     BNE.S    derror
  409.     _GetEOF                ; get ...
  410.     MOVE.L    28(A0),36(A0)        ;  ... and set ...
  411.     MOVE.L    28(A0),-(PS)        ;  ... and hold the file size
  412.     
  413.     MOVE.L    (PS),D0            ; set block size = file size
  414.     _NewHandle
  415.     BMI.S    derror
  416.     
  417.     MOVE    fsptr-base(BP),D0    ; get file stack pointer
  418.     LEA    fstack-base(BP),A1    ; file stack address
  419.     MOVE.L    A0,0(A1,D0.W)        ; stash the handle at fstack+(fsptr)
  420.     _HLock
  421.     
  422.     MOVE.L    (A0),A0            ; get start addr of block
  423.     MOVE.L    A0,TextO-base(BP)    ; set buffer start
  424.     MOVE.L    A0,D0            ; set buffer end ...
  425.     ADD.L    (PS)+,D0
  426.     MOVE.L    D0,TextE-base(BP)    ;  ... to start + size
  427.     
  428.     MOVE.L    A4,A0            ; retrieve fcb pointer
  429.     MOVE.L    TextO-base(BP),32(A0)    ; set read buffer addr in fcb
  430.     _Read                ; read data from file ...
  431.     TST    16(A0)            ; ... to scrap buffer
  432.     BNE.S    derror
  433.     _Close
  434.     _DisposPtr
  435.     JMP    go-base(BP)        ; interpret scrap buffer
  436.  
  437. DError:    MOVE    16(A0),-(PS)
  438.     _Close
  439.     _DisposPtr
  440.     JSR    pquote-base(BP)
  441.     DC.B    5,'Disk:'        ; print the error messsage
  442.    der:    JSR    dot-base(BP)        ; report the error number
  443.     JMP    huh-base(BP)
  444.  
  445.     DC.B    8,'?GE'        ; "?GESTALT"
  446.     DC.W    load-theLink    ; ( d.selector -- d.response true or false )
  447. QGestalt:        ; false if 64K ROM or no _Gestalt or bad selector
  448.     ; check for 64K ROM
  449.     MOVE    #$A86E,D0        ; _InitGraf
  450.     _GetTrapAddress.newTool
  451.     MOVE.L    A0,D1
  452.     MOVE    #$AA6E,D0        ; _InitGraf AND $200
  453.     _GetTrapAddress.newTool
  454.     CMP.L    A0,D1
  455.     BEQ.S    gser1            ; 64KROM
  456.  
  457.     ; Check for gestalt
  458.     MOVE.W    #$A89F,D0        ; _Unimplemented
  459.     _GetTrapAddress.newTool        ; NGetTrapAddress
  460.     MOVE.L    A0,D1
  461.     MOVE.W    #$A1AD,D0        ; _Gestalt
  462.     _GetTrapAddress.newOS        ; NGetTrapAddress
  463.     CMP.L    A0,D1
  464.     BEQ.S    gser1            ; no gestalt
  465.  
  466.     ; run gestalt
  467.     MOVE.L    (PS)+,D0
  468.     _Gestalt
  469.     BNE.S    gser2
  470.     MOVE.L    A0,-(PS)        ; return the result  ... and ...
  471.     MOVE    #-1,-(PS)        ; return true
  472.  gsret:    RTS
  473.  
  474.  gser1:    ADDQ.L    #4,PS            ; gestalt error
  475.  gser2:    CLR    -(PS)            ; return false
  476.     RTS
  477.  
  478.     DC.B    128+2,',S',0        ; ",S" compile a dnumber from ascii
  479.     DC.W    qgestalt-theLink
  480. CommaS:    MOVE.L    A2,A0
  481.     MOVEQ    #4,D0
  482.     @0:    MOVE.B    (IS)+,(A0)+
  483.     DBRA    D0,@0
  484.     MOVE.L    (A2),-(PS)
  485.     TST.B    fcolon-base(BP)
  486.     BEQ.S    gsret
  487.     JMP    dlit-base(BP)
  488.  
  489.     DC.B    64+9,'INT'
  490.     DC.W    commas-theLink
  491. Interp:    JMP    main-base(BP)
  492.     RTS
  493.  
  494.     DC.B    4,'ROO'            ; "room" ( -- bytes )
  495.     DC.W    interp-theLink
  496. Room:    MOVE.L    A3,A0
  497.     _RecoverHandle            ; use handle rather than pointer
  498.     _GetHandleSize
  499.     MOVE.L    A3,A0            ; Bottom
  500.     ADDA.L    D0,A0            ;  +  block size ...
  501.     SUBA.L    A2,A0            ;  -  end of dictionary
  502.     MOVE    A0,-(PS)        ;  =  unused dictionary space
  503.     RTS
  504.  
  505. CSave:    CLR    -(SP)            ; Room for which item number.
  506.     MOVE    #259,-(SP)        ; Resource ID of ALRT
  507.     CLR.L    -(SP)
  508.     _Alert                ; About Item
  509.     SUBQ    #1,(SP)+        ; check which item dismissed.
  510.     BEQ.S    save            ; save if 'ok'
  511.     RTS
  512.  
  513.     DC.B    4,'SAV'            ; "save" ( -- ) save the dictionary
  514.     DC.W    room-theLink
  515. Save:    JSR    here-base(BP)
  516.     MOVE    (PS)+,freePt-base(BP)    ; save current DP
  517.     MOVE    Dict,DictPt-base(BP)    ; save current DictPt
  518.     BSR.S    room
  519.     MOVE    (PS),freesz-base(BP)    ; save current headroom
  520.     BSR.S    negate
  521.     BSR.S    grow            ; reduce headroom to 4 bytes
  522.     move.l    a3,A0            ; bottom
  523.     _RecoverHandle            ; get DICT's handle
  524.     CLR    -(SP)
  525.     MOVE.L    A0,-(SP)        ; push 2, 1 for each operation
  526.     MOVE.L    A0,-(SP)
  527.     _ChangedResource
  528.     _HomeResFile
  529.     _UpdateResFile            ; write out the DICT
  530.     MOVE    freesz-base(BP),-(PS)
  531. Grow:    JSR    here-base(BP)
  532.     MOVE    (PS)+,D1        ; hold rel DP in D1
  533.     MOVE.L    IS,-(PS)
  534.     JSR    torel-base(BP)
  535.     MOVE    (PS)+,D2
  536.     MOVE.L    (RS),-(PS)
  537.     JSR    torel-base(BP)
  538.     JSR    swapp-base(BP)
  539.     MOVEA.L    expand-base(BP),A0
  540.     JMP    (A0)            ; JSR won't return here
  541.  
  542.     DC.B    4,'>AB'            ; ">abs" (to-abs)
  543.     DC.W    save-theLink        ; ( addr16 -- daddr32 )
  544. toAbs:    CLR.L    D0
  545.     MOVE    (PS)+,D0        ; pop rel addr
  546.     LEA    0(BP,D0.W),A0        ; calc as offset to base ...
  547.     MOVE.L    A0,-(PS)        ; ...  and push
  548.     RTS
  549.  
  550.     DC.B    64+6,'NEG'        ; "negate" ( n -- -n )
  551.     DC.W    toabs-theLink
  552. negate:    NEG    (PS)
  553.     RTS
  554.  
  555.     DC.B    5,'SPA'            ; "space" ( -- ) emit a space
  556.     DC.W    negate-theLink
  557. space:    MOVE.L    #32,D0
  558.     jmp    EmitCode-Base(BP)
  559.  
  560.     DC.B    4,'TYP'            ; "type" ( rel.addr len -- )
  561.     DC.W    space-theLink        ;  emit len characters from rel.addr
  562. Type:    MOVEM.L    D3/D4,-(SP)        ; don't trash registers!
  563.     MOVE    (PS)+,D3        ; get character count
  564.     SUBQ.B    #1,D3
  565.     MOVE    (PS)+,D4        ; get string relative address
  566.     @0:    MOVE.B    0(BP,D4.W),D0        ; get character byte
  567.     jsr    EmitCode-Base(BP)    ; print character byte
  568.     ADDQ    #1,D4
  569.     DBRA    D3,@0
  570.     MOVEM.L    (SP)+,D3/D4        ; restore registers
  571.     BRA.S    space
  572.  
  573. pQuote:    ;   runtime part of ."
  574.     MOVE.L    (RS),-(PS)        ; push the addr of the string
  575.     JSR    torel-base(BP)
  576.     ADDQ    #1,(PS)            ; skip the length byte
  577.     MOVE.L    (RS),A0
  578.     CLR.L    D0            ; clear the character count
  579.     MOVE.B    (A0),D0            ; get the length
  580.     MOVE    D0,-(PS)        ; push it
  581.     ADDQ    #2,D0
  582.     ANDI    #$FFFE,D0        ; be sure its even
  583.     ADD.L    D0,(RS)            ; skip over string upon return
  584.     bra.s    type    ;-base(BP)        ; type the string
  585.     
  586.     DC.B    4,'EMI'            ; "emit" ( n -- ) send the ascii
  587.     DC.W    type-theLink    ;                 to the terminal
  588. Emit:    MOVE    (PS)+,D0
  589.   EmitCode:                ; Emit contents of D0
  590.     CMP.B    #13,D0            ; is it a <cr>
  591.     BEQ.S    doCR
  592.     CMP.B    #8,D0            ; is it a <del>?
  593.     BEQ.S    doDEL
  594.     ANDI    #$FF,D0
  595.     MOVE    D0,-(A7)
  596.     _DrawChar
  597.     BSR.S    penh
  598.     MOVE    WContRect+6-base(BP),D0    ; right coord of WContRect
  599.     CMP    D0,D1            ; is the position beyond the edge
  600.     BLS.S    emitr            ; no
  601.     
  602.   doCR:    PEA    Scratch-base(BP)
  603.     _GetPen
  604.     MOVE    Scratch-base(BP),D1
  605.     MOVE    WContRect+4-base(BP),D0    ; bottom coord of WContRect
  606.     SUB    #11,D0
  607.     CMP    D0,D1            ; is the position below the window
  608.     BLS.S    @0            ; no
  609.  
  610.     ; yes it is below the bottom of the window, so scroll up 11 pixels
  611.     CLR.L    -(A7)            ; Make room for a region handle.
  612.     _NewRgn                ; get handle into (A7)
  613.     PEA    WContRect-base(BP)    ; rect to scroll
  614.     CLR    -(A7)            ; no horiz.
  615.     MOVE    #$FFF5,-(A7)        ; 11 pix. vert.
  616.     MOVE.L    8(A7),-(A7)        ; push the region handle
  617.     _ScrollRect
  618.     _DisposRgn
  619.  
  620.     MOVE    WContRect+4-base(BP),D1    ; bottom coord of WContRect
  621.     SUBQ    #4,D1
  622.     BRA.S    @1
  623.  
  624.     @0: ADD    #11,D1            ; Add line height to pen location
  625.     @1:    MOVE    #1,-(A7)
  626.     MOVE    D1,-(A7)
  627.     _MoveTo
  628.  emitr:    RTS
  629.  
  630.  doDEL:    BSR.S    penh
  631.     CMP    #6,D1            ; first column?
  632.     BLT    Beep            ; beep return
  633.     SUB    #6,D1            ; back up
  634.     MOVE    D1,-(SP)
  635.     MOVE    Scratch-base(BP),-(SP)
  636.     _MoveTo
  637.     RTS
  638.  
  639.   penh:    PEA    Scratch-base(BP)
  640.     _GetPen
  641.     MOVE    Scratch+2-base(BP),D1
  642.     RTS
  643.  
  644.     DC.B    6,'EXP'            ; "expect" ( addr count -- )
  645.     DC.W    emit-theLink
  646. Expect:    MOVEM.L    D4/IS,-(SP)
  647.     JSR    swapp-base(BP)        ; leave number of chars on stack
  648.     MOVE    (PS)+,D0        ; addr
  649.     LEA    0(BP,D0.W),IS        ; set IS to the input address
  650.     CLR    Counter
  651.     MOVE    (PS)+,D4
  652.     @0:    JSR    key-base(BP)
  653.     MOVE    (PS)+,D5
  654.     CMPI    #CR,D5            ; if key = CR
  655.     BNE.S    @1
  656.     MOVE.B    #BL,0(IS,Counter)
  657.     CLR.B    1(IS,Counter)
  658.     MOVE.B    #BL,2(IS,Counter)
  659.     BRA.S    @3
  660.     @1:    CMPI    #BS,D5            ; if key = backspace
  661.     BNE.S    @2
  662.     TST    Counter            ; do nothing if first key is BS
  663.     BEQ.S    @0
  664.     SUBQ    #1,Counter        ; decriment counter
  665.     JSR    dodel-base(BP)
  666.     JSR    space-base(BP)        ;    ... rubout char
  667.     JSR    dodel-base(BP)
  668.     BRA.S    @0
  669.     @2:    MOVE.B    D5,0(IS,Counter)    ; stash the key into input buffer
  670.     ADDQ    #1,Counter
  671.     MOVE    D5,D0
  672.     JSR    emitcode-base(BP)
  673.     CMP    D4,Counter        ; is count=number of chars to get?
  674.     BNE.S    @0
  675.     @3:    JSR    docr-base(BP)
  676.     MOVEM.L    (SP)+,D4/IS
  677.     RTS
  678.  
  679.     DC.B    64+1,'0',0,0        ; "0" ( -- 0 )
  680.     DC.W    expect-theLink
  681. Zero:    CLR    -(PS)
  682.     RTS
  683.     
  684.     DC.B    64+4,'DRO'        ; "drop" ( n -- )
  685.     DC.W    zero-theLink
  686. drop:    ADDQ.L    #2,PS
  687.     RTS
  688.  
  689.     DC.B    4,'SWA'            ; "swap" ( n1 n2 -- n2 n1 )
  690.     DC.W    drop-theLink
  691. swapp:    MOVE.L    (PS)+,D0
  692.     SWAP    D0
  693.     MOVE.L    D0,-(PS)
  694.     RTS
  695.  
  696.     DC.B    64+5,'2DR'        ; "2drop" ( d -- )
  697.     DC.W    swapp-theLink
  698. TwoDrop:
  699.     ADDQ.L    #4,PS
  700.     RTS
  701.  
  702.     DC.B    4,'NUL'            ; "null" ( -- )
  703.     DC.W    twodrop-theLink
  704. Null:    RTS
  705.     
  706.     DC.B    6,'FOR'            ; "forget" ( -- ) forgets dictionary
  707.     DC.W    null-theLink
  708. Forget:    JSR    tick-base(BP)
  709.     MOVE    (PS)+,D0
  710.     MOVE    -2(BP,D0.W),Dict
  711.     LEA    -6(BP,D0.W),DP
  712.     RTS
  713.  
  714.     DC.B    8,'CON'            ; "constant" compile: ( n16 -- )
  715.     DC.W    forget-theLink    ;            runtime: ( -- n16 )
  716. Const:    JSR    token-base(BP)        ; make a header for the next token
  717.     JSR    header-base(BP)
  718.     JSR    marco-base(BP)        ; to return a constant
  719.     JSR    literal-base(BP)    ; compile time comma, runtime push
  720.     MOVE    #$4E75,(DP)+        ; compile  rts 
  721.     RTS
  722.  
  723.     DC.B    6,'CRE'            ; "create" compile: ( -- ) 
  724.     DC.W    const-theLink        ;          runtime: ( -- addr16 )
  725. Create:    JSR    token-base(BP)        ; give token this runtime action:
  726.     JSR    header-base(BP)
  727.     MOVE    #$3D3C,(DP)+        ;  • move     #nnnn,-(ps)
  728.     JSR    here-base(BP)
  729.     ADDQ    #6,(PS)
  730.     MOVE    (PS)+,(DP)+        ; supply the nnnn from above
  731.     MOVE    #$4EEB,(DP)+        ;  • jmp     null-base(bp)
  732.     MOVE.L    DP,DoesAddr-base(BP)    ; set DoesAddr to this "null"
  733.     MOVE    #null-base,(DP)+
  734.     RTS
  735.  
  736.     DC.B    5,'DOE'            ; "does>" ( -- ) (use after create)
  737.     DC.W    create-theLink        ;   set runtime action 
  738. Does:    MOVE.L    (RS)+,D0        ; pop the return address
  739.     SUB.L    BP,D0            ; convert to rel.addr
  740.     MOVE.L    DoesAddr-base(BP),A0    ; load jmp d(bp) address from create
  741.     MOVE    D0,(A0)            ; and stash rel.addr into it
  742.     RTS                ; returns same as ;
  743.  
  744.     DC.B    5,'ALL'            ; "allot" ( n16 -- )
  745.     DC.W    does-theLink        ;  compiles nada into the dictionary
  746. Allot:    ADDQ    #1,(PS)
  747.     ANDI    #$FFFE,(PS)        ; make it even!
  748.     ADDA    (PS)+,DP        ; increment the dictionary pointer
  749.     RTS
  750.  
  751.     DC.B    8,'VAR'            ; "variable" compile: ( -- )
  752.     DC.W    allot-theLink        ;            runtime: ( -- addr16 )
  753. Variable:
  754.     JSR    token-base(BP)        ; give token this runtime action:
  755.     JSR    header-base(BP)
  756.     JSR    marco-base(BP)        ; Sun May 1, 1988 04:24:44
  757.     MOVE    #$3D3C,(DP)+        ;  • move   #nnnn,-(ps)
  758.     JSR    here-base(BP)
  759.     ADDQ    #4,(PS)            ;    calculate nnnn
  760.     MOVE    (PS)+,(DP)+        ;  • (this is the nnnn)
  761.     MOVE    #$4E75,(DP)+        ;  • rts
  762.     ADDQ.L    #2,DP            ; 2 allot
  763.     RTS
  764.  
  765.     DC.B    3,'AE:'
  766.     DC.W    variable-theLink
  767. aColon:    MOVE    #AEvents-base,-(PS)
  768.     @0:    JSR    at-base(BP)
  769.     ADDI    #10,(PS)
  770.     MOVE    (PS),-(PS)
  771.     JSR    at-base(BP)
  772.     TST    (PS)+
  773.     BNE.S    @0
  774.     MOVE    (PS)+,D1
  775.     MOVE.L    A2,D0
  776.     SUB.L    BP,D0
  777.     MOVE    D0,0(BP,D1.W)
  778.     MOVE.L    (PS)+,(A2)+
  779.     MOVE.L    (PS)+,(A2)+
  780.     LEA    4(A2),A0
  781.     SUBA.L    A3,A0
  782.     MOVE    A0,(A2)+
  783.     CLR    (A2)+
  784.     MOVE    #$4EBA,(A2)+
  785.     MOVE    #aepre-base,-(PS)
  786.     JSR    back-base(BP)
  787.     JMP    rbrack-base(BP)
  788.  
  789.     DC.B    128+3,';AE'
  790.     DC.W    acolon-theLink
  791. semiae:    MOVE    #$4EAB,(A2)+
  792.     MOVE    #aepost-base,(A2)+
  793.     JMP    semi-base(BP)
  794.  
  795.     DC.B    64+5,'>NA'        ; ">name" ( 'addr -- name.addr )
  796.     DC.W    semiae-theLink
  797. toname:    SUBQ    #6,(PS)
  798.     RTS
  799.     
  800.     DC.B    64+5,'>LI'        ; ">link" ( 'addr -- link.addr )
  801.     DC.W    toname-theLink
  802. tolink:    SUBQ    #2,(PS)
  803.     RTS
  804.  
  805.     DC.B    3,'ID.'            ; "id." ( addr -- )
  806.     DC.W    tolink-theLink
  807. IDDot:    JSR    toname-base(BP)
  808.     MOVEA.L    DP,A0
  809.     MOVEQ.L    #5,D0
  810.     @0:    MOVE.L    #$C9C9C9C9,(A0)+    
  811.     DBRA    D0,@0
  812.     MOVE    (PS)+,D0
  813.     MOVE.L    0(BP,D0.W),(DP)
  814.     JSR    here-base(BP)
  815.     MOVE    (PS),-(PS)
  816.     JSR    cat-base(BP)
  817.     ANDI    #$1F,(PS)        ; look at 5 lsb's
  818.     ADDQ    #1,2(PS)
  819.     JSR    type-base(BP)
  820.     JMP    space-base(BP)
  821.     
  822.     DC.B    5,'WOR'            ; "words" ( -- ) list words
  823.     DC.W    iddot-theLink
  824. Words:    MOVE.L    D3,-(SP)        ; preserve register
  825.     MOVE    Dict,D3            ; start with the last word defined
  826.     @0:    MOVE    D3,-(PS)        ; push the name address
  827.     ADDQ    #6,(PS)            ; get the CFA
  828.     BSR.S    iddot            ; print the name
  829.      MOVE    4(BP,D3.W),D3        ; put the next name addr into D3
  830.     TST.B    1(BP,D3.W)        ; Quit if name is 0
  831.     BEQ.S    @1            ; do next word if not=0
  832.     JSR    qterm-base(BP)
  833.         TST    (PS)+
  834.     BEQ.S    @0
  835.     @1:    MOVE.L    (SP)+,D3        ; restore register
  836.     RTS
  837.     
  838.     DC.B    3,'PAD'            ; "pad" ( -- ) conversion pad
  839.     DC.W    words-theLink
  840. Pad:    JSR    here-base(BP)
  841.     ADDI    #40,(PS)        ; pad is 40 bytes from HERE.
  842.     RTS
  843.     
  844.     DC.B    4,'HOL'            ; "hold" ( c -- ) place c at ...
  845.     DC.W    pad-theLink        ; ... addr in Held.
  846. Hold:    SUBQ    #1,held-base(BP)
  847.     MOVE    held-base(BP),-(PS)
  848.     JMP    cstore-base(BP)
  849.     
  850.     DC.B    4,'SIG'            ; "sign" ( sf dval -- dval )
  851.     DC.W    hold-theLink
  852. Sign:    JSR    rote-base(BP)
  853.     TST    (PS)+
  854.     BGE.S    @0
  855.     MOVE    #'-',-(PS)
  856.     BSR.S    hold
  857.     @0:    RTS
  858.  
  859.     DC.B    4,'DAB'            ; "dabs" ( dval -- |dval| )
  860.     DC.W    sign-theLink
  861. Dabs:    TST    (PS)
  862.     BGE.S    @0
  863.     JSR    dneg-base(BP)
  864.     @0:    RTS
  865.  
  866.     DC.B    2,'<#',0        ; "<#" ( -- )
  867.     DC.W    dabs-theLink
  868. LSharp:    BSR.S    pad
  869.     MOVE    (PS)+,held-base(BP)
  870.     MOVEA.L    DP,A0
  871.     MOVE    #9,D0
  872.     @0:    CLR.L    (A0)+
  873.     DBRA    D0,@0
  874.     MOVE    #30,-(PS)
  875.     BRA.S    hold
  876.  
  877.     DC.B    2,'#>'.0        ; "#>" ( dval -- addr len )
  878.     DC.W    lsharp-theLink
  879. SharpG:    ADDQ.L    #2,PS
  880.     MOVE    held-base(BP),(PS)
  881.     BSR.S    pad
  882.     MOVE    2(PS),-(PS)        ; over
  883.     ADDQ    #1,(PS)
  884.     JMP    minus-base(BP)
  885.     
  886.     DC.B    1,'#',0,0        ; "#" ( dval -- d/base )
  887.     DC.W    sharpg-theLink
  888. Sharp:    MOVE    NBase-base(BP),-(PS)
  889.     JSR    msmod-base(BP)
  890.     JSR    rote-base(BP)
  891.     CMPI    #9,(PS)            ; is top of stack < 9?
  892.     BLE.S    @0
  893.     ADDQ    #7,(PS)
  894.     @0:    ADDI    #48,(PS)
  895.     JMP    hold-base(BP)
  896.  
  897.     DC.B    2,'#S',0        ; "#s" ( dval -- 0 0 )
  898.     DC.W    sharp-theLink
  899. Sharps:    BSR.S    sharp
  900.     TST.L    (PS)
  901.     BNE.S    sharps
  902.     RTS
  903.  
  904.     DC.B    2,'D.',0        ; "d." ( dval -- )
  905.     DC.W    sharps-theLink
  906. DDot:    JSR    swapp-base(BP)
  907.     MOVE    2(PS),-(PS)
  908.     JSR    dabs-base(BP)
  909.     BSR.S    lsharp
  910.     BSR.S    sharps
  911.     JSR    sign-base(BP)
  912.     BSR.S    sharpg
  913.     JMP    type-base(BP)
  914.  
  915.     DC.B    2,'U.',0        ; "u." ( uval -- )
  916.     DC.W    ddot-theLink
  917. UDot:    CLR    -(PS)
  918.     BRA.S    ddot
  919.  
  920.     DC.B    3,'S>D'            ; "s>d" ( n -- d )
  921.     DC.W    udot-theLink
  922. SToD:    MOVE    (PS),-(PS)        ; dup
  923.     JMP    zerolt-base(BP)        ; 0<
  924.  
  925.     DC.B    1,'.',0,0        ; "." ( n -- )
  926.     DC.W    stod-theLink
  927. Dot:    BSR.S    stod
  928.     BRA.S    ddot
  929.  
  930.     DC.B    130,'."',0        ; "."" ( -- ) compiler part of (.")
  931.     DC.W    dot-theLink
  932. dotQ:    MOVE    #pQuote-base,-(PS)
  933.     JSR    compile-base(BP)    ; compile a call to (.")
  934.     JSR    here-base(BP)        ; ( -- addr )
  935.     MOVE    #'"',-(PS)        ; ( -- addr 34 )
  936.     JSR    word-base(BP)        ; ( -- addr )
  937.     JSR    cat-base(BP)        ; ( -- c )
  938.     ADDQ    #1,(PS)            ; ( -- c+1 )
  939.     JMP    allot-base(BP)        ; enclose the string in dictionary
  940.     
  941.     DC.B    129,'(',0,0        ; "(" ( -- ) begin comment
  942.     DC.W    dotq-theLink
  943. Comment    CMPI.B    #41,(IS)+        ; read in characters until ")"
  944.     BNE.S    Comment
  945.     RTS
  946.  
  947.     DC.B    5,'CMO'            ; "cmove" ( addr1 addr2 len -- )
  948.     DC.W    comment-theLink        ; from figFORTH, fixed 8/3/91
  949. CMove:    MOVE    (PS)+,D0        ; D0 = length
  950.     MOVE    (PS)+,D1
  951.     LEA    0(BP,D1.W),A1        ; A1 = addr2
  952.     MOVE    (PS)+,D1
  953.     LEA    0(BP,D1.W),A0        ; A0 = addr1
  954.     CMPA.L    A0,A1
  955.     BPL.S    @2
  956.  
  957.     BRA.S    @1            ;  addr1 > addr2
  958.     @0:    MOVE.B    (A0)+,(A1)+
  959.     @1:    DBRA    D0,@0
  960.     RTS
  961.  
  962.     @2:    ADDA    D0,A0            ;  addr1 ≤ addr2
  963.     ADDA    D0,A1
  964.     BRA.S    @4
  965.     @3:    MOVE.B    -(A0),-(A1)
  966.     @4:    DBRA    D0,@3
  967.     RTS
  968.     
  969.     DC.B    4,'FIL'            ; "fill" ( addr count char -- )
  970.     DC.W    cmove-theLink
  971. Fill:    MOVE    (PS)+,D0        ; character
  972.     MOVE    (PS)+,D1        ; count
  973.     SUBQ    #1,D1            ; decrement count
  974.     MOVE    (PS)+,A0        ; relative addr
  975.     LEA    0(BP,A0.W),A0        ; get absolute addr
  976.     @0:    MOVE.B    D0,0(A0,D1.W)        ; put char into addr + count
  977.         DBRA    D1,@0            ; decrement count & loop until 0
  978.     RTS
  979.     
  980.     DC.B    9,'-TR'            ; "-trailing"
  981.     DC.W    fill-theLink        ;  ( addr count -- addr new.count )
  982. dtrail:    MOVE    (PS)+,D1            ; get the count
  983.     MOVE    (PS),D0            ; get the rel.addr
  984.     LEA    0(BP,D0.W),A0        ; get the abs.addr
  985.     @0:    CMPI.B    #$20,-1(A0,D1.W)    ; BEGIN  is char at addr+count $20
  986.     DBNE    D1,@0            ; NOT UNTIL
  987.     MOVE    D1,-(PS)        ; put new count on stack
  988.     RTS
  989.     
  990.     DC.B    64+2,'1+',0        ; "1+" ( n -- n+1 )
  991.     DC.W    dtrail-theLink
  992. OnePl:    ADDQ    #1,(PS)
  993.     RTS
  994.  
  995.     DC.B    64+2,'1-',0        ; "1-" ( n -- n-1 )
  996.     DC.W    onepl-theLink
  997. OneMi:    SUBQ    #1,(PS)
  998.     RTS
  999.     
  1000.     DC.B    64+2,'2+',0        ; "2+" ( n -- n+2 )
  1001.     DC.W    onemi-theLink
  1002. TwoPl:    ADDQ    #2,(PS)
  1003.     RTS
  1004.     
  1005.     DC.B    64+2,'2*',0        ; "2*" ( n -- n*2 )
  1006.     DC.W    twopl-theLink
  1007. ToStar:    ASL    (PS)
  1008.     RTS
  1009.  
  1010.     DC.B    64+2,'2/',0        ; "2/" ( n -- n/2 )
  1011.     DC.W    tostar-theLink
  1012. ToDiv:    ASR    (PS)
  1013.     RTS
  1014.     
  1015.     DC.B    1,'@',0,0        ; "@" (at) ( addr16 -- n16 )
  1016.     DC.W    todiv-theLink
  1017. At:    MOVE    (PS),D0            ; DANGER: odd values crash this
  1018.     MOVE    0(BP,D0.W),(PS)    
  1019.     RTS
  1020.  
  1021.     DC.B    1,'!',0,0        ; "!" (store) ( n16 addr16 -- )
  1022.     DC.W    at-theLink
  1023. Store:    MOVE    (PS)+,D0        ; DANGER: odd values crash this
  1024.     MOVE    (PS)+,0(BP,D0.W)
  1025.     RTS
  1026.  
  1027.     DC.B    2,'C!',0        ; "c!" (sea-store)( n8 addr16 -- )
  1028.     DC.W    store-theLink
  1029. CStore:    MOVE    (PS)+,D0        ; get the rel.addr (odd OK)
  1030.     ADDQ.L    #1,PS            ; align the stack
  1031.     MOVE.B    (PS)+,0(BP,D0.W)    ; put data at the addr
  1032.     RTS
  1033.  
  1034.     DC.B    2,'C@',0        ; "c@" (sea-at) ( addr16 -- n8 )
  1035.     DC.W    cstore-theLink
  1036. CAt:    MOVE    (PS),D0            ; get rel.addr (odd OK)
  1037.     CLR    (PS)            ; clear the result
  1038.     MOVE.B    0(BP,D0.W),1(PS)    ; stash the second byte
  1039.     RTS
  1040.  
  1041.     DC.B    64+2,'L@',0        ; "l@" (el-at) ( daddr32 -- n16 )
  1042.     DC.W    cat-theLink
  1043. LAt:    MOVEA.L    (PS)+,A0        ; get the double number "real" addr
  1044.     MOVE    (A0),-(PS)        ; fetch the contents
  1045.     RTS
  1046.  
  1047.     DC.B    64+2,'L!',0        ; "l!" (el-store)( n16 daddr32 -- )
  1048.     DC.W    lat-theLink
  1049. LStore:    MOVEA.L    (PS)+,A0
  1050.     MOVE    (PS)+,(A0)
  1051.     RTS
  1052.     
  1053.     DC.B    64+3,'DL@'        ; "dl@" ( daddr32 -- d32 )
  1054.     DC.W    lstore-theLink
  1055. DLAt:    MOVEA.L    (PS),A0
  1056.     MOVE.L    (A0),(PS)
  1057.     RTS
  1058.     
  1059.     DC.B    64+3,'DL!'        ; "dl!" ( d32 daddr32 -- )
  1060.     DC.W    dlat-theLink
  1061. DLStor:    MOVE.L    (PS)+,A0
  1062.     MOVE.L    (PS)+,(A0)
  1063.     RTS
  1064.  
  1065.     DC.B    2,'+!',0        ; "+!" ( n16 addr16 -- )
  1066.     DC.W    dlstor-theLink
  1067. pstore:    MOVE    (PS)+,D0
  1068.     MOVE    (PS)+,D1
  1069.     ADD    D1,0(BP,D0.W)
  1070.     RTS
  1071.     
  1072.     DC.B    64+4,'CBL'        ; "cblk" ( -- addr ) of fint
  1073.     DC.W    pstore-theLink
  1074. cBLK:    MOVE    #fint-base,-(PS)
  1075.     RTS
  1076.     
  1077.     DC.B    64+6,'CST'        ; "cstate" ( -- addr ) of fcolon
  1078.     DC.W    cblk-theLink
  1079. cState:    MOVE    #fcolon-base,-(PS)
  1080.     RTS
  1081.  
  1082.     DC.B    64+4,'BAS'        ; "base" ( -- addr )
  1083.     DC.W    cstate-theLink        ;   variable for the numeric radix
  1084. BaseA:    MOVE    #nbase-base,-(PS)
  1085.     RTS
  1086.  
  1087.     DC.B    64+3,'TIB'        ; "tib" ( -- addr )
  1088.     DC.W    basea-theLink        ;   variable for Terminal Input Buf.
  1089. TIB:    MOVE    #termbuf-base,-(PS)
  1090.     RTS
  1091.  
  1092.     DC.B    64+6,'LAT'        ; "latest" ( -- addr )
  1093.     DC.W    tib-theLink        ;   variable for the last dict word
  1094. Latest:    MOVE    Dict,-(PS)        ; push contents of the dict register
  1095.     RTS
  1096.  
  1097.     DC.B    64+3,'R0@'        ; "r0@" ( -- dabs.addr )
  1098.     DC.W    latest-theLink        ;   dabs.addr of r0
  1099. R0at:    MOVE.L    rzero-base(BP),-(PS)
  1100.     RTS
  1101.  
  1102.     DC.B    64+3,'RP@'        ; "rp@" ( -- dabs.addr )
  1103.     DC.W    r0at-theLink        ;   current addr of the return stack
  1104. RPat:    MOVE.L    RS,-(PS)
  1105.     RTS
  1106.  
  1107.     DC.B    64+3,'S0@'        ; "s0@" ( -- dabs.addr )
  1108.     DC.W    rpat-theLink        ;   dabs.addr of s0
  1109. S0at:    MOVE.L    szero-base(BP),-(PS)
  1110.     RTS
  1111.  
  1112.     DC.B    64+3,'SP@'        ; "sp@" ( -- dabs.addr )
  1113.     DC.W    s0at-theLink        ; address of the current stack cell
  1114. SPat:    MOVE.L    PS,-(PS)
  1115.     RTS
  1116.  
  1117.     DC.B    3,'HEX'            ; "hex" ( -- )
  1118.     DC.W    spat-theLink
  1119. hex:    MOVE    #$10,nbase-base(BP)
  1120.     RTS
  1121.  
  1122.     DC.B    7,'DEC'            ; "decimal" ( -- )
  1123.     DC.W    hex-theLink
  1124. decimal    MOVE    #10,nbase-base(BP)
  1125.     RTS
  1126.     
  1127.     DC.B    4,'?DU'            ; "?dup" ( n -- n n OR n [if n=0] )
  1128.     DC.W    decimal-theLink
  1129. qdup:    TST    (PS)
  1130.     BNE.S    dup
  1131.     RTS
  1132.  
  1133.     DC.B    64+3,'DUP'        ; "dup" ( n -- n n )
  1134.     DC.W    qdup-thelink
  1135. dup:    MOVE    (PS),-(PS)
  1136.     RTS
  1137.  
  1138.     DC.B    64+4,'OVE'        ; "over" ( n1 n2 -- n1 n2 n1 )
  1139.     DC.W    dup-theLink
  1140. over:    MOVE    2(PS),-(PS)
  1141.     RTS
  1142.  
  1143.     DC.B    3,'ROT'            ; "rot" ( n1 n2 n3 -- n2 n3 n1 )
  1144.     DC.W    over-theLink
  1145. rote:    MOVE.L    (PS)+,D0
  1146.     MOVE    (PS)+,D1
  1147.     MOVE.L    D0,-(PS)
  1148.     MOVE    D1,-(PS)
  1149.     RTS
  1150.  
  1151.     DC.B    64+4,'2DU'        ; "2dup" ( n1 n2 -- n1 n2 n1 n2 )
  1152.     DC.W    rote-theLink
  1153. todup:    MOVE.L    (PS),-(PS)
  1154.     RTS
  1155.  
  1156.     DC.B    5,'2SW'            ; "2swap"
  1157.     DC.W    todup-theLink        ;  ( n1 n2 n3 n4 -- n3 n4 n1 n2 )
  1158. toswap:    MOVE.L    (PS)+,D0
  1159.     MOVE.L    (PS)+,D1
  1160.     MOVE.L    D0,-(PS)
  1161.     MOVE.L    D1,-(PS)
  1162.     RTS
  1163.     
  1164.     DC.B    64+2,'>R',0        ; ">r" ( n -- ) rstack: ( -- n16 )
  1165.     DC.W    toswap-theLink
  1166. toR:    MOVE    (PS)+,-(RS)
  1167.     RTS
  1168.  
  1169.     DC.B    64+2,'R>',0        ; "r>" ( -- n ) rstack: ( n16 -- )
  1170.     DC.W    tor-theLink
  1171. Rfrom:    MOVE    (RS)+,-(PS)
  1172.     RTS
  1173.  
  1174.     DC.B    64+1,'R',0,0        ; "r" ( -- n ) rs: ( n16 -- n16 )
  1175.     DC.W    rfrom-theLink
  1176. Are:    MOVE    (RS),-(PS)
  1177.     RTS
  1178.  
  1179.     DC.B    4,'EXI'            ; "exit" ( -- ) drops return address
  1180.     DC.W    are-theLink
  1181. Exit:    ADDQ.L    #4,RS
  1182.     RTS
  1183.     
  1184.     DC.B    64+1,'+',0,0        ; "+" ( n1 n2 -- n1+n2 )
  1185.     DC.W    exit-theLink
  1186. plus:    MOVE    (PS)+,D0
  1187.     ADD    D0,(PS)
  1188.     RTS
  1189.  
  1190.     DC.B    1,'-',0,0        ; "-" ( n1 n2 -- n1-n2 )
  1191.     DC.W    plus-theLink
  1192. minus:    NEG    (PS)
  1193.     BRA.S    plus
  1194.  
  1195.     DC.B    1,'*',0,0        ; "*" ( n1 n2 -- n1*n2 )
  1196.     DC.W    minus-theLink
  1197. times:    MOVE    (PS)+,D0
  1198.     MULS    (PS)+,D0
  1199.     MOVE    D0,-(PS)
  1200.     RTS
  1201.  
  1202.     DC.B    4,'/MO'            ; "/mod ( n1 n2 -- rem quot )
  1203.     DC.W    times-theLink
  1204. Smod:    MOVE    (PS)+,D0
  1205.     BNE.S    @0
  1206.     BRA.S    sfail
  1207.     @0:    MOVE    (PS)+,D1
  1208.     EXT.L    D1
  1209.     DIVS    D0,D1
  1210.     SWAP    D1
  1211.     MOVE.L    D1,-(PS)
  1212.     RTS
  1213.  
  1214.     DC.B    1,'/',0,0        ; "/" ( n1 n2 -- quotient )
  1215.     DC.W    smod-theLink
  1216. Slash:    JSR    smod-base(BP)
  1217.     JSR    swapp-base(BP)
  1218.     ADDQ.L    #2,PS
  1219.     RTS
  1220.  
  1221.     DC.B    3,'MOD'            ; "mod"    ( n1 n2 -- remainder )
  1222.     DC.W    slash-theLink
  1223. mod:    JSR    smod-base(BP)
  1224.     ADDQ.L    #2,PS
  1225.     RTS
  1226.  
  1227.     DC.B    2,'*/',0        ; "*/" ( n1 n2 n3 -- n1*n2/n3 )
  1228.     DC.W    mod-theLink
  1229. SSlash:    MOVE    (PS)+,D1
  1230.     BNE.S    sok
  1231.     ADDQ.L    #2,PS
  1232.  sfail:    MOVE    #-1,(PS)
  1233.     RTS
  1234.    sok:    MOVE    (PS)+,D0
  1235.     MULS    (PS),D0
  1236.     DIVS    D1,D0
  1237.     MOVE    D0,(PS)
  1238.     RTS
  1239.  
  1240.     DC.B    2,'U*',0        ; "u*" ( n1 n2 -- d32 )
  1241.     DC.W    sslash-theLink
  1242. UStar:    MOVE    (PS)+,D0
  1243.     MULU    (PS)+,D0
  1244.     MOVE.L    D0,-(PS)
  1245.     RTS
  1246.     
  1247.     DC.B    5,'M/M'            ; "m/mod" from King&Knight
  1248.     DC.W    ustar-theLink        ; ( num32 denom16 -- rem16 quot32 )
  1249. MSMod:    TST    (PS)            ; test for div by zero
  1250.     BNE.S    @0
  1251.     ADDQ.L    #4,PS
  1252.     BRA.S    sfail
  1253.     @0:    MOVE.L    D2,-(SP)        ; save D2
  1254.     MOVEQ    #0,D2            ; clear it
  1255.     MOVE    (PS)+,D2        ; pop denom into D2.W
  1256.     MOVE.L    (PS)+,D1        ; pop num into D1.L
  1257.     MOVE    D1,-(SP)        ; hold num.l on rstack
  1258.     CLR    D1
  1259.     SWAP    D1
  1260.     DIVU    D2,D1
  1261.     MOVE    D1,D0
  1262.     MOVE    (SP)+,D1
  1263.     DIVU    D2,D1
  1264.     SWAP    D1
  1265.     MOVE    D1,-(PS)        ; push remainder
  1266.     MOVE    D0,D1
  1267.     SWAP    D1
  1268.     MOVE.L    D1,-(PS)        ; push quotient
  1269.     MOVE.L    (SP)+,D2        ; restore register
  1270.     RTS
  1271.     
  1272.     DC.B    64+7,'DNE'        ; "dnegate" ( d32 -- -d32 )
  1273.     DC.W    msmod-theLink
  1274. DNeg:    NEG.L    (PS)
  1275.     RTS
  1276.     
  1277.     DC.B    64+2,'D+',0        ; "d+" ( d1 d2 -- d1+d2 )
  1278.     DC.W    dneg-theLink
  1279. DPlus:    MOVE.L    (PS)+,D0
  1280.     ADD.L    D0,(PS)
  1281.     RTS
  1282.     
  1283.     DC.B    128+2,'IF',0        ; "if" ( flag -- ) at runtime
  1284.     DC.W    dplus-theLink        ;      ( -- addr ) at compile time
  1285. pIf:    MOVE.L    #$4A5E6700,(DP)+    ; compile tst (ps)+  beq ...
  1286.   pi1:    bsr.s    pbegin
  1287. ;    JSR    here-base(BP)        ; leave address on stack
  1288.     ADDQ.L    #2,DP            ; make room for offset
  1289.     RTS
  1290.     
  1291.     DC.B    128+5,'WHI'        ; "while" ( flag -- ) at runtime
  1292.     DC.W    pif-theLink        ;    ( -- addr ) at compile time
  1293. pWhile:    BRA.S    pIf
  1294.     
  1295.     DC.B    128+4,'ELS'        ; "else" ( -- ) at runtime
  1296.     DC.W    pwhile-theLink        ; ( addr -- addr ) at compile time
  1297. pElse:    MOVE    #$6000,(DP)+
  1298.     bsr.s    pi1
  1299. ;     JSR    here-base(BP)
  1300. ;     ADDQ.L    #2,DP
  1301.     JSR    swapp-base(BP)
  1302.     BRA.S    pthen
  1303.  
  1304.     DC.B    128+4,'THE'        ; "then" ( -- ) at runtime
  1305.     DC.W    pelse-theLink        ;   ( addr -- ) at compile time
  1306. pThen:    bsr.s    pbegin
  1307. ;    JSR    here-base(BP)        ; : THEN  HERE OVER - SWAP ! ;
  1308.     MOVE    2(PS),-(PS)        ; over
  1309.     JSR    minus-base(BP)
  1310.     JSR    swapp-base(BP)
  1311.     JMP    store-base(BP)
  1312.  
  1313.     DC.B    128+6,'REP'        ; "repeat" ( -- ) at runtime
  1314.     DC.W    pthen-theLink        ; ( b.addr w.addr -- ) at c.time
  1315. pRepet:    MOVE    #$6000,(DP)+        ; compile bra ...
  1316.     JSR    swapp-base(BP)
  1317.     BSR.S    back
  1318.     BRA.S    pThen            ; HERE OVER - SWAP ! ;
  1319.  
  1320.     DC.B    128+5,'BEG'        ; "begin" ( -- ) at runtime
  1321.     DC.W    prepet-theLink        ;    ( -- addr ) at compile time
  1322. pBegin:    JMP    here-base(BP)
  1323.  
  1324.     DC.B    128+5,'UNT'        ; "until" ( flag -- ) at runtime
  1325.     DC.W    pbegin-theLink        ;      ( addr -- ) at compile time
  1326. pUntil    MOVE.L    #$4A5E6700,(DP)+    ; compile tst (ps)+  beq ...
  1327.     BRA.S    back
  1328.     
  1329.     DC.B    128+5,'AGA'        ; "again" ( -- ) at runtime
  1330.     DC.W    puntil-theLink        ;    ( addr -- ) at compile time
  1331. pAgain:    MOVE    #$6000,(DP)+        ; compile bra ...
  1332.     BRA.S    back
  1333.  
  1334.     DC.B    4,'BAC'            ; "back" ( addr -- )
  1335.     DC.W    pagain-theLink        ;  compile negative displacement
  1336. back:    bsr.s    pbegin
  1337. ;    JSR    here-base(BP)
  1338.     JSR    minus-base(BP)
  1339.     MOVE    (PS),D0            ; get the target addr into d0
  1340.     BGE.S    @0
  1341.     NEG    D0            ; make it positive
  1342.     @0:    ANDI    #$FF80,D0        ; if > 1 byte
  1343.     BEQ.S    @1
  1344.     JMP    comma-base(BP)        ; then comma it as a long branch
  1345.     @1:    MOVE.B    1(PS),-1(DP)        ; else make it a short branch
  1346.     JMP    drop-base(BP)
  1347.  
  1348.     DC.B    128+2,'DO',0        ; "do" ( -- addr ) at compile time
  1349.     DC.W    back-theLink        ;  ( limit index -- ) at runtime
  1350. do:    MOVE    #$2F1E,(DP)+        ; • move.l (ps)+,-(ps)
  1351.     bra.s    pbegin
  1352. ;    JMP    here-base(BP)        ; leave this address for loop
  1353.     
  1354.     DC.B    128+4,'LOO'        ; "loop" ( -- ) at runtime
  1355.     DC.W    do-theLink        ;   ( addr -- ) at compile time
  1356. Loop:    MOVE    #$5257,(DP)+        ;  • addq #1,(rs)  (increment ix)
  1357.   pl:    MOVE    #$3017,(DP)+        ;  • move (rs),d0  (get ix)
  1358.     MOVE.L    #$B06F0002,(DP)+    ;  • cmp  2(rs),d0 (check lim)
  1359.     MOVE    #$6B00,(DP)+        ;  • bmi  ...      (loop if ix<lim)
  1360.     BSR.S    back            ; comma in the displacement to 'do'
  1361.     MOVE    #$588F,(DP)+        ;  • addq.l #4,rs    (drop ix&lim)
  1362.     RTS
  1363.     
  1364.     DC.B    128+5,'+LO'        ; "+loop" ( n -- ) at runtime
  1365.     DC.W    loop-theLink        ;   ( addr -- ) at compile time
  1366. pLoop:    MOVE.L    #$301ED157,(DP)+    ;  • move (ps)+,d0
  1367.     BRA.S    pl            ;  • add  d0,(rs)
  1368.     
  1369.     DC.B    5,'LEA'            ; "leave" ( -- )
  1370.     DC.W    ploop-theLink        ;  set the index to the limit
  1371. Leave:    MOVE    6(RS),4(RS)
  1372.     RTS
  1373.  
  1374.     DC.B    2,'0<',0        ; "0<" ( n -- flag )
  1375.     DC.W    leave-theLink
  1376. ZeroLT:    TST    (PS)
  1377.     BLT.S    true
  1378.  false:    CLR    (PS)
  1379.     RTS
  1380.  true:    MOVE    #-1,(PS)
  1381.     RTS
  1382.  
  1383.     DC.B    2,'0>',0        ; "0>" ( n -- flag )
  1384.     DC.W    zerolt-theLink
  1385. ZeroGT:    NEG    (PS)
  1386.     BRA.S    zerolt
  1387.  
  1388.     DC.B    2,'0=',0        ; "0=" ( n -- flag )
  1389.     DC.W    zerogt-theLink
  1390. ZeroEQ:    TST    (PS)
  1391.     BEQ.S    true
  1392.     BRA.S    false
  1393.  
  1394.     DC.B    1,'=',0,0        ; "=" ( n1 n2 -- flag )
  1395.     DC.W    zeroeq-theLink
  1396. equal:    JSR    minus-base(BP)
  1397.     BRA.S    zeroeq
  1398.  
  1399.     DC.B    1,'<',0,0        ; "<" ( n1 n2 -- flag )
  1400.     DC.W    equal-theLink
  1401. lesst:    JSR    minus-base(BP)
  1402.     BRA.S    zerolt
  1403.  
  1404.     DC.B    1,'>',0,0        ; ">" ( n1 n2 -- flag )
  1405.     DC.W    lesst-theLink
  1406. moret:    JSR    minus-base(BP)
  1407.     BRA.S    zerogt
  1408.  
  1409.     DC.B    64+3,'AND'        ; "and"    ( n1 n2 -- n1(and)n2 )
  1410.     DC.W    moret-theLink
  1411. andd:    MOVE    (PS)+,D0
  1412.     AND    D0,(PS)
  1413.     RTS
  1414.  
  1415.     DC.B    64+2,'OR',0        ; "or" ( n1 n2 -- n1(or)n2 )
  1416.     DC.W    andd-theLink
  1417. orr:    MOVE    (PS)+,D0
  1418.     OR    D0,(PS)
  1419.     RTS
  1420.     
  1421.     DC.B    64+3,'XOR'        ; "xor" ( n1 n2 -- n1(xor)n2 )
  1422.     DC.W    orr-theLink
  1423. xor:    MOVE    (PS)+,D0
  1424.     EOR    D0,(PS)
  1425.     RTS
  1426.  
  1427.     DC.B    3,'ABS'            ; "abs"    ( n1 -- abs(n1) )
  1428.     DC.W    xor-theLink
  1429. abs:    TST    (PS)
  1430.     BGE.S    @0
  1431.     NEG    (PS)
  1432.     @0:    RTS
  1433.  
  1434.         DC.B    3,'MIN'            ; "min" ( n1 n2 -- n(min) )
  1435.     DC.W    abs-theLink
  1436. min:    MOVE    (PS)+,D0
  1437.     CMP    (PS),D0
  1438.     BLT.S    pd0
  1439.     RTS
  1440.    pd0:    MOVE    D0,(PS)
  1441.     RTS
  1442.  
  1443.         DC.B    3,'MAX'            ; "max" ( n1 n2 -- n(max) )
  1444.     DC.W    min-theLink
  1445. max:    MOVE    (PS)+,D0
  1446.     CMP    (PS),D0
  1447.     BGE.S    pd0
  1448.     RTS
  1449.  
  1450.     DC.B    2,'2@',0        ; "2@" ( addr -- d )
  1451.     DC.W    max-theLink        ; 32 bit fetch
  1452. TwoAt:    MOVE    (PS)+,D0
  1453.     MOVE.L    0(BP,D0.W),-(PS)
  1454.     RTS
  1455.  
  1456.     DC.B    2,'2!',0        ; "2!" ( d addr -- )
  1457.     DC.W    twoat-theLink        ; 32 bit store
  1458. TwoStore:
  1459.     MOVE    (PS)+,D0
  1460.     MOVE.L    (PS)+,0(BP,D0.W)
  1461.     RTS
  1462.  
  1463.     DC.B    9,'2CO'            ; "2constant"
  1464.     DC.W    twostore-theLink    ; defining: ( d -- )
  1465. TwoCon:    JSR    token-base(BP)        ; executing: ( -- d )
  1466.     JSR    header-base(BP)
  1467.     JSR    dlit-base(BP)
  1468.     MOVE    #$4E75,(DP)+
  1469.     RTS
  1470.  
  1471.     DC.B    9,'2VA'            ; "2variable"
  1472.     DC.W    twocon-theLink        ; defining: ( -- )
  1473. TwoVar:    JSR    variable-base(BP)    ; executing: ( -- addr )
  1474.     ADDQ.L    #2,DP
  1475.     RTS
  1476.  
  1477.     DC.B    64+3,'2>R'        ; "2>r" ( d -- ) rstack: ( -- d )
  1478.     DC.W    twovar-theLink
  1479. TwoToR:    MOVE.L    (PS)+,-(RS)
  1480.     RTS
  1481.  
  1482.     DC.B    64+3,'2R>'        ; "2r>" ( -- d ) rstack: ( d -- )
  1483.     DC.W    twotor-theLink
  1484. TwoRFrom:
  1485.     MOVE.L    (RS)+,-(PS)
  1486.     RTS
  1487.     
  1488.     DC.B    3,'A>R'            ; "a>r" ( addr -- )
  1489.     DC.W    tworfrom-theLink    ;   rstack: ( -- dabs.addr )
  1490. AToR:    JSR    toabs-base(BP)
  1491.     MOVE.L    (SP)+,A0
  1492.     MOVE.L    (PS)+,-(SP)
  1493.     JMP    (A0)
  1494.  
  1495.     DC.B    64+5,'2OV'        ; "2over" ( d1 d2 -- d1 d2 d1 )
  1496.     DC.W    ator-theLink
  1497. TwoOver:
  1498.     MOVE.L    4(PS),-(PS)
  1499.     RTS
  1500.  
  1501.     DC.B    4,'2RO'            ; "2rot" ( d1 d2 d3 -- d2 d3 d1 )
  1502.     DC.W    twoover-theLink
  1503. TwoRot:    MOVE.L    (PS)+,D0
  1504.     MOVE.L    (PS)+,D1
  1505.     MOVE.L    (PS),A0
  1506.     MOVE.L    D1,(PS)
  1507.     MOVE.L    D0,-(PS)
  1508.     MOVE.L    A0,-(PS)
  1509.     RTS
  1510.  
  1511. ; floating point stack manipulation
  1512.     DC.B    64+5,'FDR'        ; FDROP ( n1 n2 n3 n4 n5 -- )
  1513.     DC.W    tworot-theLink
  1514. fdrop:    ADDQ.L    #6,PS
  1515.     ADDQ.L    #4,PS
  1516.     RTS
  1517.  
  1518.     DC.B    4,'FDU'        ; FDUP ( n5 n4 n3 n2 n1 -- n5 n4 n3 n2 n1  n5 n4 n3 n2 n1 )
  1519.     DC.W    fdrop-theLink
  1520. fdup:    LEA    10(PS),A0
  1521.     MOVE.L    -(A0),-(PS)
  1522.     MOVE.L    -(A0),-(PS)
  1523.     MOVE.W    -(A0),-(PS)
  1524.     RTS
  1525.  
  1526.     DC.B    5,'FSW'            ; FSWAP ( f1 f2 -- f2 f1 )
  1527.     DC.W    fdup-theLink
  1528. fswap:    LEA    (PS),A0
  1529.     LEA    10(PS),A1
  1530.     MOVEQ    #4,D1
  1531.     @0:    MOVE    (A1),D0
  1532.     MOVE    (A0),(A1)+
  1533.     MOVE    D0,(A0)+
  1534.     DBRA    D1,@0
  1535.     RTS
  1536.  
  1537.     DC.B    5,'FPI'            ; FPICK ( fn..f1 m|n≥m≥1 -- fn..f1 fm )
  1538.     DC.W    fswap-theLink
  1539. fpick:    MOVE    #$0A,-(PS)
  1540.     JSR    times-base(BP)
  1541.     MOVE    (PS)+,D0
  1542.     LEA    0(PS,D0.W),A0
  1543.     MOVE.L    -(A0),-(PS)
  1544.     MOVE.L    -(A0),-(PS)
  1545.     MOVE    -(A0),-(PS)
  1546.     RTS
  1547.  
  1548.     DC.B    5,'FPA'        ; FPACK ( fn..f1 fnew m -- fn..f1 ) ( fm = fnew )
  1549.     DC.W    fpick-theLink
  1550. fpack:    MOVE    #$0A,-(PS)
  1551.     JSR    times-base(BP)
  1552.     MOVE    (PS)+,D0
  1553.     LEA    0(PS,D0.W),A0
  1554.     MOVE.L    (PS)+,(A0)+
  1555.     MOVE.L    (PS)+,(A0)+
  1556.     MOVE    (PS)+,(A0)+
  1557.     RTS
  1558.  
  1559.     DC.B    5,'FRO'        ; FROLL ( fn..f1 m -- fn..fm+1 fm-1..f1 fm )
  1560.     DC.W    fpack-theLink
  1561. froll:    JSR    fpick-base(BP)
  1562.     LSR.W    #1,D0
  1563.     @0:    MOVE    -(A0),10(A0)
  1564.     DBRA D0,@0
  1565.     JSR    fswap-base(BP)
  1566.     JMP    fdrop-base(BP)
  1567.  
  1568. ; float - double number conversion
  1569.     DC.B    3,'D>F'            ; D>F ( d -- n1 n2 n3 n4 n5 )
  1570.     DC.W    froll-theLink
  1571. dtof:    MOVE.L    (PS)+,(DP)
  1572.     MOVE.L    DP,-(RS)
  1573.     SUBQ.L    #6,PS
  1574.     SUBQ.L    #4,PS
  1575.     PEA    (PS)
  1576.     FL2X
  1577.     RTS
  1578.  
  1579.     DC.B    3,'F>D'            ; F>D ( n1 n2 n3 n4 n5 -- d )
  1580.     DC.W    dtof-theLink
  1581. ftod:    PEA    (PS)
  1582.     MOVE.L    DP,-(RS)
  1583.     FX2L
  1584.     JSR    fdrop-base(BP)  
  1585.     MOVE.L    (DP),-(PS)
  1586.     RTS
  1587.  
  1588.     DC.B    2,'F@',0        ; F@ ( addr -- n5 n4 n3 n2 n1 )
  1589.     DC.W    ftod-theLink
  1590. fat:    MOVE    (PS)+,D0
  1591.     LEA    10(BP,D0.W),A0
  1592.     MOVE.L    -(A0),-(PS)
  1593.     MOVE.L    -(A0),-(PS)
  1594.     MOVE    -(A0),-(PS)
  1595.     RTS
  1596.  
  1597.     DC.B    2,'F!',0        ; F! ( n5 n4 n3 n2 n1 addr -- )
  1598.     DC.W    fat-theLink
  1599. fstore:    MOVE    (PS)+,D0
  1600.     LEA    0(BP,D0.W),A0
  1601.     MOVE.L    (PS)+,(A0)+
  1602.     MOVE.L    (PS)+,(A0)+
  1603.     MOVE    (PS)+,(A0)
  1604.     RTS
  1605.  
  1606.     DC.B    8,'FLI'        ; FLITERAL ( comp: n5 n4 n3 n2 n1 -- |exec: -- n5 n4 n3 n2 n1 )
  1607.     DC.W    fstore-theLink
  1608. flit:    MOVE    (PS),D0
  1609.     MOVE    2(PS),D1
  1610.     MOVE    8(PS),(PS)
  1611.     MOVE    6(PS),2(PS)
  1612.     MOVE    D0,8(PS)
  1613.     MOVE    D1,6(PS)
  1614.     MOVEQ    #4,D0
  1615.     @0:    JSR    literal-base(BP)
  1616.     DBRA    D0,@0
  1617.     RTS
  1618.  
  1619.     DC.B    2,'F,',0        ; F, ( n5 n4 n3 n2 n1 -- )
  1620.     DC.W    flit-theLink
  1621. fcomma:    MOVE.L    (PS)+,(DP)+
  1622.     MOVE.L    (PS)+,(DP)+
  1623.     MOVE    (PS)+,(DP)+
  1624.     RTS
  1625.  
  1626.     DC.B    9,'FCO'        ; FCONSTANT ( comp: f -- ) ( run: -- f )
  1627.     DC.W    fcomma-theLink
  1628. fcon:    JSR    create-base(BP)
  1629.     BSR.S    fcomma
  1630.     JSR    does-base(BP)
  1631.     BRA.S    fat
  1632.  
  1633.     DC.B    9,'FVA'        ; FVARIABLE ( compile: -- ) ( run: -- addr )
  1634.     DC.W    fcon-theLink
  1635. fvar:    JSR    variable-base(BP)
  1636.     ADDQ.L #8,DP
  1637.     RTS
  1638.  
  1639.     DC.B    3,'SCI'            ; SCI ( decimal.places -- )
  1640.     DC.W    fvar-theLink
  1641. sci:    CLR    -(PS)
  1642.   sci1:    MOVE.L    (PS)+,form-base(BP)
  1643.     RTS
  1644.  
  1645.     DC.B    3,'FIX'            ; FIX ( decimal.places -- )
  1646.     DC.W    sci-theLink
  1647. fix:    MOVE    #$FFFF,-(PS)
  1648.     BRA.S    sci1
  1649.  
  1650.     DC.B    2,'F.',0        ; F. ( n5 n4 n3 n2 n1 -- )
  1651.     DC.W    fix-theLink
  1652. fdot:    PEA    form-base(BP)
  1653.     PEA    (PS)
  1654.     PEA    $14(DP)
  1655.     FX2DEC
  1656.     JSR    fdrop-base(BP)
  1657.     PEA    form-base(BP)
  1658.     PEA    $14(DP)
  1659.     MOVE.L    A2,-(RS)
  1660.     FDEC2STR
  1661.     JSR    here-base(BP)
  1662.     JSR    count-base(BP)
  1663.     JMP    type-base(BP)
  1664.  
  1665.     DC.B    8,'FCO'        ; FCOMPARE ( f1 f2 -- f1 f2 [flag: -1|f1<f2 0|f1=f2 1|f1>f2] )
  1666.     DC.W    fdot-theLink
  1667. fcomp:    MOVE    #1,-(PS)
  1668.     PEA    2(PS)
  1669.     PEA    12(PS)
  1670.     FCMPX
  1671.     BGE.S    @0
  1672.     NEG    (PS)
  1673.     RTS
  1674.     @0:    BNE.S    @1
  1675.     CLR    (PS)
  1676.     @1:    RTS
  1677.  
  1678.     DC.B    2,'F+',0        ; F+ ( f1 f2 -- f1+f2 )
  1679.     DC.W    fcomp-theLink
  1680. fplus:    PEA    (PS)
  1681.     PEA    10(PS)
  1682.     FADDX
  1683.   fd1:    JMP    fdrop-base(BP)
  1684.  
  1685.     DC.B    2,'F-',0        ; F- ( f1 f2 -- f1-f2 )
  1686.     DC.W    fplus-theLink
  1687. fminus:    PEA    (PS)
  1688.     PEA    10(PS)
  1689.     FSUBX
  1690.     BRA.S    fd1
  1691.  
  1692.     DC.B    2,'F*',0        ; F* ( f1 f2 -- f1*f2 )
  1693.     DC.W    fminus-theLink
  1694. fstar:    PEA    (PS)
  1695.     PEA    10(PS)
  1696.     FMULX
  1697.     BRA.S    fd1
  1698.  
  1699.     DC.B    2,'F/',0        ; F/ ( f1 f2 -- f1/f2 )
  1700.     DC.W    fstar-theLink
  1701. fslash:    PEA    (PS)
  1702.     PEA    10(PS)
  1703.     FDIVX
  1704.     BRA.S    fd1
  1705.  
  1706.     DC.B    4,'FRE'            ; FREM ( f1 f2 -- rem[f1/f2] )
  1707.     DC.W    fslash-theLink
  1708. frem:    PEA    (PS)
  1709.     PEA    10(PS)
  1710.     FREMX
  1711.     BRA.S    fd1
  1712.  
  1713.     DC.B    2,'F^',0        ; F^ ( f1 f2 -- f1^f2 )
  1714.     DC.W    frem-theLink
  1715. ftothe:    PEA    (PS)
  1716.     PEA    10(PS)
  1717.     FXPWRY
  1718.     BRA.S    fd1
  1719.  
  1720.     DC.B    4,'FIN'            ; FINT ( f -- int[f] )
  1721.     DC.W    ftothe-theLink
  1722. finte:    PEA    (PS)
  1723.     FTINTX
  1724.     RTS
  1725.  
  1726.     DC.B    4,'FAB'            ; FABS ( f -- |f| )
  1727.     DC.W    finte -theLink
  1728. fabs:    PEA    (PS)
  1729.     FABSX
  1730.     RTS
  1731.  
  1732.     DC.B    5,'FSQ'            ; FSQRT ( f -- sqrt[f] )
  1733.     DC.W    fabs-theLink
  1734. fsqrt:    PEA    (PS)
  1735.     FSQRTX
  1736.     RTS
  1737.  
  1738.     DC.B    4,'FSI'            ; FSIN ( f -- sin[f] )
  1739.     DC.W    fsqrt-theLink
  1740. fsin:    PEA    (PS)
  1741.     FSINX
  1742.     RTS
  1743.  
  1744.     DC.B    4,'FCO'            ; FCOS ( f -- cos[f] )
  1745.     DC.W    fsin-theLink
  1746. fcos:    PEA    (PS)
  1747.     FCOSX
  1748.     RTS
  1749.  
  1750.     DC.B    4,'FTA'            ; FTAN ( f -- tan[f] )
  1751.     DC.W    fcos-theLink
  1752. ftan:    PEA    (PS)
  1753.     FTANX
  1754.     RTS
  1755.  
  1756.     DC.B    4,'FAT'            ; FATN ( f -- atn[f] )
  1757.     DC.W    ftan-theLink
  1758. fatn:    PEA    (PS)
  1759.     FATNX
  1760.     RTS
  1761.  
  1762.     DC.B    4,'FEX'            ; FEXP ( f1 -- e^f1 )
  1763.     DC.W    fatn-theLink
  1764. fexp:    PEA    (PS)
  1765.     FEXPX
  1766.     RTS
  1767.  
  1768.     DC.B    3,'FLN'            ; FLN ( f1 -- ln[f1] )
  1769.     DC.W    fexp-theLink
  1770. fln:    PEA    (PS)
  1771.     FLNX
  1772.     RTS
  1773.  
  1774.     DC.B    4,'@PE'            ; "@pen" ( -- h v )
  1775.     DC.W    fln-theLink
  1776. AtPen:    PEA    (DP)
  1777.     _GetPen
  1778.     MOVE.L    (DP),-(PS)
  1779.     RTS
  1780.  
  1781.     DC.B    64+4,'!PE'        ; "!pen" ( h v -- )
  1782.     DC.W    atpen-theLink
  1783. SetPen:    MOVE.L    (PS)+,-(SP)
  1784.     _MoveTo
  1785.     RTS
  1786.  
  1787.     DC.B    64+3,'-TO'        ; "-to" ( h v -- )
  1788.     DC.W    setpen-theLink
  1789. LineTo:    MOVE.L    (PS)+,-(SP)
  1790.     _LineTo
  1791.     RTS
  1792.  
  1793.     DC.B    64+5,'PMO'        ; "pmode" ( mode -- )
  1794.     DC.W    lineto-theLink
  1795. PMode:    MOVE    (PS)+,-(SP)
  1796.     _PenMode
  1797.     RTS
  1798.  
  1799.     DC.B    6,'@MO'            ; "@mouse" ( -- h v )
  1800.     DC.W    pmode-theLink
  1801. AtMouse:
  1802.     SUBQ.L    #4,PS
  1803.     PEA    (PS)
  1804.     _GetMouse
  1805.     RTS
  1806.  
  1807.     DC.B    7,'?BU'            ; "?button" ( -- flag )
  1808.     DC.W    atmouse-theLink
  1809. QButton:
  1810.     CLR    -(SP)
  1811.     _Button
  1812.     MOVE    (SP)+,-(PS)
  1813.     BEQ.S    @0
  1814.     SUBI    #257,(PS)
  1815.     @0:    RTS
  1816.